package Redirector;
use Apache2::RequestRec ();
use Apache2::Const -compile=>":common";
use APR::Table ();
use Net::DNS;
use strict;

my $timeout = 0.25;
my $two_level_tld_url = "http://spamcheck.freeapp.net/two-level-tlds";
my $two_level_tld_cache = "/var/cache/two-level-tlds";
my %two_level_tld = do {
    eval {
	require LWP::Simple;
	eval { LWP::Simple::mirror($two_level_tld_url, $two_level_tld_cache) } =~ /^(2|304)/
	    or die "Couldn't mirror $two_level_tld_url to $two_level_tld_cache: $@\n";
    };

    open my $fh, $two_level_tld_cache
	or die "Couldn't open $two_level_tld_cache: $!\n";
    map +(/^(\S+)/, 1), <$fh>;
};

my $resolver = Net::DNS::Resolver->new(
    udp_timeout    => $timeout,
    tcp_timeout    => $timeout,
    persistent_udp => 1,
    persistent_tcp => 1,
);

sub handler
{
    my ($r) = @_;

    # this should include everything after the <Location /....> path
    my $url = $r->path_info
	or return Apache2::Const::SERVER_ERROR;

    # strip leading slashes
    $url =~ s|^/+||;

    # double slashes are collapsed by apache, add back.
    $url =~ s|^(https?:/(?!/))|$1/|i;

    # add leading protocol if not present
    $url =~ s|^(?!https?://)|http://|i;

    # allow http or https urls, extract the hostname portion
    my ($host) = $url =~ m|^(?:https?://)([^/]+)|i
	or return Apache2::Const::SERVER_ERROR;

    # don't accept usernames/passwords in URL
    # they're visible which is generally bad,
    # and are often used by phishers to obfuscate the address
    $host !~ /[:\@]/
	or return Apache2::Const::FORBIDDEN;

    # we want to check the url is not in SURBL to avoid being abused by spammers
    my $lookup;

    if ($host =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/ and $1 < 256 and $2 < 256 and $3 < 256 and $4 < 256) {
	$lookup = lc "$4.$3.$2.$1";
    } elsif ($host =~ /([\w-]+)\.([\w-]+)\.([\w-]+)\.?$/ and $two_level_tld{lc "$2.$3"}) {
	$lookup = lc "$1.$2.$3";
    } elsif ($host =~ /([\w-]+)\.([\w-]+)\.?$/) {
	$lookup = lc "$1.$2";
    } else {
	return Apache2::Const::SERVER_ERROR;
    }

    if (my $packet = $resolver->search("$lookup.multi.surbl.org."))
    {
	# any 'A' record in the response indicates presence on the SURBL list
	grep $_->type eq 'A', $packet->answer
	    and return Apache2::Const::FORBIDDEN;
    }

    $r->headers_out->set(Location => $url.($r->args ? "?".$r->args : ""));
    return Apache2::Const::REDIRECT;
}

1;
